home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / shazam.exe / GMISC.IMP < prev    next >
Text File  |  1992-09-01  |  11KB  |  341 lines
  1.    {*******************************************************************
  2.  
  3.    GMISC.IMP
  4.  
  5.    *******************************************************************}
  6.    {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
  7.  
  8.    DRIVE
  9.  
  10.    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
  11.    {===================================================================
  12.  
  13.    Use DOS "Parse Filename" to validate drive number.
  14.    Does not access the drive.
  15.    Does not correct for "phantom" floppy drives.
  16.  
  17.    ===================================================================}
  18. function IsDosDrive ( DriveNum : byte ) : boolean ;
  19. var
  20.    FCB                       : array [ 1 .. 36 ] of byte ;
  21.    FileName                  : array [ 1 .. 3 ] of char ;
  22.    R                         : registers ;
  23. begin
  24.    IsDosDrive                := FALSE ;
  25.    if DriveNum < 1 then EXIT ;
  26.    if DriveNum > 26 then EXIT ;
  27.    fillchar ( FCB, sizeof ( FCB ), 0 ) ;
  28.    FileName                  := 'x:'#0 ;
  29.    FileName [ 1 ]            := Chr ( DriveNum + 64 ) ;
  30.    with R do
  31.    begin
  32.       AH                     := $29 ;
  33.       AL                     := $00 ;
  34.       DS                     := seg ( FileName ) ;
  35.       SI                     := ofs ( FileName ) ;
  36.       ES                     := seg ( FCB ) ;
  37.       DI                     := ofs ( FCB ) ;
  38.       MsDos ( R ) ;
  39.       if AL = $FF then EXIT ;
  40.    end ;
  41.    IsDosDrive                := TRUE ;
  42. end ;
  43.    {===================================================================
  44.                                                                DOS 3.1+
  45.    IOCTL:  Check if block device is remote.
  46.    NOTE:  DOS returns TRUE, even if the disk number is invalid.
  47.           Use program logic or "IsDosDrive" to avoid invalid disks.
  48.    ===================================================================}
  49. function IsRemote ( DriveNum : byte ) : boolean ;
  50. var
  51.    Regs                      : registers ;
  52. begin
  53.    IsRemote                  := FALSE ;
  54.    Regs.AH                   := $44 ;
  55.    Regs.AL                   := $09 ;
  56.    Regs.BL                   := DriveNum ;
  57.    Regs.DX                   := 0 ;
  58.    MsDos ( Regs ) ;
  59.    if Regs.Flags and FCarry = 0 then
  60.       if ( Regs.DX and $1000 ) <> 0 then   { Bit 12, 0=local 1=remote }
  61.          IsRemote            := TRUE ;
  62. end ;
  63.    {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
  64.  
  65.    NETWORK
  66.  
  67.    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
  68.    {===================================================================
  69.  
  70.    16-character machine name; blank if not on net              DOS 3.0+
  71.  
  72.    ===================================================================}
  73. function NetMachineName      : string ;
  74. var
  75.    S                         : string ;
  76.    Regs                      : registers ;
  77. begin
  78.    NetMachineName            := '' ;
  79.    FillChar ( S , SizeOf ( S ) , #32 ) ;
  80.    S [ 0 ]                   := #16 ;
  81.    S                         := S + #0 ;
  82.    Regs.AX                   := $5E00 ;
  83.    Regs.DS                   := seg ( S ) ;
  84.    Regs.DX                   := ofs ( S ) + 1 ;
  85.    Regs.CL                   := 0 ;
  86.    Regs.CH                   := 0 ;
  87.    MsDos ( Dos.Registers ( regs ) ) ;
  88.    if Regs.CH = 0 then EXIT ;                     { Name not defined }
  89.    if Regs.Flags and FCarry <> 0 then EXIT ;                 { Error }
  90.    while S [ length ( S ) ]= #0 do
  91.       delete ( S , length ( S ) , 1 ) ;                   { trim NUL }
  92.    while S [ length ( S ) ] = #32 do
  93.       delete ( S , length ( S ) , 1 ) ;                 { trim space }
  94.    NetMachineName            := S ;
  95. end;
  96.    {===================================================================
  97.  
  98.    Return "0" for stand-alone, or up to 8 character name on network.
  99.  
  100.    ===================================================================}
  101. function PcName              : string ;
  102. var
  103.    S                         : string ;
  104. begin
  105.    S                         := NetMachineName ;
  106.    if length ( S ) > 8 then
  107.       S [ 0 ]                := #8 ;
  108.    if S = '' then
  109.       S                      := '0' ;
  110.    PcName                    := S ;
  111. end ;
  112.    {===================================================================
  113.  
  114.    SOUND - for past begin/end of file.
  115.  
  116.    ===================================================================}
  117. procedure Buzz ;
  118. begin
  119.    sound ( 220 ) ;
  120.    delay ( 200 ) ;
  121.    nosound ;
  122. end ;
  123.    {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
  124.  
  125.    MEMORY
  126.  
  127.    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
  128.    {===================================================================
  129.  
  130.    ADDRESS - Return the address in bytes...
  131.  
  132.    ===================================================================}
  133. function Address ( VAR A ) : longint ;
  134. var
  135.    L                         : longint ;
  136. begin
  137.    L                         := seg ( A ) ;
  138.    L                         := L * 16 ;
  139.    inc ( L , ofs ( A ) ) ;
  140.    Address                   := L ;
  141. end ;
  142.    {===================================================================
  143.  
  144.    TRAPPED - Memory deallocated below "HeapPtr"
  145.    
  146.    ===================================================================}
  147. function HeapTrapped : longint ;
  148. begin
  149.    HeapTrapped               := MemAvail - MaxAvail ;
  150. end ;
  151.    {===================================================================
  152.  
  153.    USED - Amount of allocated memory
  154.    
  155.    ===================================================================}
  156. function HeapUsed : longint ;
  157. begin
  158.    HeapUsed                  := Address ( HeapPtr^ ) -
  159.                                 Address ( HeapOrg^ ) -
  160.                                 HeapTrapped ;
  161. end ;
  162.    {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
  163.  
  164.    REDIRECTION
  165.  
  166.    |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
  167.    {===================================================================
  168.  
  169.    Return TRUE if handle (0=input, 1=output) is console device
  170.  
  171.    ===================================================================}
  172. function IsConsole ( Handle : word ) : boolean ;
  173. var
  174.    Regs                      : Registers ;
  175. begin
  176.    with Regs do
  177.    begin
  178.       AX                     := $4400 ;
  179.       BX                     := Handle ;
  180.       MsDos ( Regs ) ;
  181.       if ( DX and $80 ) = 0 then
  182.          IsConsole           := FALSE
  183.       else
  184.          IsConsole           := ( DX and $02 <> 0 ) or
  185.                                 ( DX and $01 <> 0 ) ;
  186.    end;
  187. end ;
  188.    {===================================================================
  189.  
  190.    Return TRUE if
  191.    1.  Input was redirected from the command-line.
  192.    2.  The program has redirected input internally.
  193.  
  194.    ===================================================================}
  195. function IsInputRedirected : boolean ;
  196. begin
  197.    IsInputRedirected         := not IsConsole ( DOS.TextRec ( Input ).Handle ) ;
  198. end ;
  199.    {===================================================================
  200.  
  201.    Return TRUE if
  202.    1.  Output was redirected from the command-line.
  203.    2.  The program has redirected output internally.
  204.  
  205.    ===================================================================}
  206. function IsOutputRedirected : boolean ;
  207. begin
  208.    IsOutputRedirected        := not IsConsole ( DOS.TextRec ( Output ).Handle ) ;
  209. end ;
  210.    {===================================================================
  211.  
  212.    Reset "input" as text device.
  213.  
  214.    ===================================================================}
  215. function RedirectInputTo ( S : string ) : boolean ;
  216. begin
  217.    RedirectInputTo           := FALSE ;
  218. {$I-}
  219.    Assign ( input , S ) ;
  220.    if IOresult <> 0 then EXIT ;
  221.    Reset ( input ) ;
  222.    if IOresult <> 0 then EXIT ;
  223. {$I+}
  224.    RedirectInputTo           := TRUE ;
  225. end ;
  226.    {===================================================================
  227.  
  228.    Appends to "output" as text device.
  229.  
  230.    ===================================================================}
  231. function RedirectOutputTo ( S : string ) : boolean ;